home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
GFILES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-13
|
41KB
|
1,441 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }
unit gfiles;
interface
uses crt,dos,overlay,
gentypes,configrt,modem,statret,subs1,subs2,textret,gensubs,
windows,mainr1,mainr2,overret1,userret,protocol,mainmenu,subs3;
procedure gfilesection;
implementation
procedure gfilesection;
var showit,itsotay,ymodem:boolean;
var gfile:file of gfilerec;
gf:gfilerec;
gfilea:file of gfilearea;
gfa:gfilearea;
curarea:integer;
procedure beepbeep (ok:integer);
begin
delay (500);
write (^B^M);
case ok of
0:write ('Transfer completed.');
1:write ('Transfer Aborted.');
2:write ('Transfer Aborted.')
end;
writeln (^G^M)
end;
procedure parse3 (s:lstr; var a,b,c:integer);
var p:integer;
procedure parse1 (var n:integer);
var ns:lstr;
begin
ns[0]:=#0;
while (p<=length(s)) and (s[p] in ['0'..'9']) do begin
ns:=ns+s[p];
p:=p+1
end;
if length(ns)=0
then n:=0
else n:=valu(ns);
if p<length(s) then p:=p+1
end;
begin
p:=1;
parse1 (a);
parse1 (b);
parse1 (c)
end;
function later (d1,t1,d2,t2:sstr):boolean;
var m1,da1,y1,m2,da2,y2:integer;
function latertime (t1,t2:sstr):boolean;
var n1,n2:integer;
begin
latertime:=timeval(t1)>timeval(t2)
end;
begin
parse3 (d1,m1,da1,y1);
parse3 (d2,m2,da2,y2);
if y1=y2
then if m1=m2
then if da1=da2
then later:=timeval(t1) > timeval(t2)
else later:=da1>da2
else later:=m1>m2
else later:=y1>y2
end;
function Numgfiles:integer;
begin
numgfiles:=filesize(gfile)
end;
function NumAreas:integer;
begin
numareas:=filesize (gfilea)
end;
procedure Seekgfile (n:integer);
begin
seek (gfile,n-1)
end;
procedure Seekgfilea (n:integer);
begin
seek (gfilea,n-1)
end;
procedure Assigngf (N:Integer);
begin
assign (gfile,uploaddir+'GFILE'+strr(n));
close (gfile);
end;
function Makearea:boolean;
var num,n:integer;
gfatmp:gfilearea;
begin
makearea:=false;
writestr ('Create Area '+strr(numareas+1)+'? [y/n]: *');
writeln;
if yes then begin
writestr ('Area Name: *');
if length(input)=0 then exit;
gfatmp.Name:=input;
writestr ('Access Level: *');
if length(input)=0 then exit;
gfatmp.Level:=valu(input);
writestr ('Sponsor [CR/'+unam+']:');
if length(input)=0 then input:=unam;
gfatmp.Sponsor:=input;
gfatmp.UpAble:=True;
writestr('Able to Upload to area [CR/Yes]: *');
if length(input)=0 then input:='Y';
if upcase(input[1])<>'Y' then gfatmp.UpAble:=False;
writestr('Upload Directory [CR/'+uploaddir+']: *');
if length(input)=0 then input:=uploaddir;
gfatmp.gfileDir:=input;
Seekgfilea (numareas+1);
write (gfilea,gfatmp);
gfa:=gfatmp;
Curarea:=NumAreas+1;
Assigngf(CurArea);
rewrite (gfile);
writeln ('Area created');
makearea:=true;
writelog (3,6,gfatmp.Name);
end
end;
procedure opengfile;
var n:integer;
begin
n:=ioresult;
assign (gfilea,uploaddir+'gfiledir.dat');
reset (gfilea);
if ioresult<>0 then begin
close (gfilea);
n:=ioresult;
rewrite (gfilea);
itsotay:=makearea;
if not itsotay then erase (gfilea);
end else itsotay:=true;
end;
function getfname (path:lstr; name:mstr):lstr;
var l:lstr;
begin
l:=path;
if length(l)<>0 then
if not (upcase(l[length(l)]) in [':','\'])
then l:=l+'\';
l:=l+name;
getfname:=l;
end;
function getapath:lstr;
var q,r:integer;
f:file;
b:boolean;
p:lstr;
begin
getapath:=gfa.gfiledir;
repeat
writestr ('Upload Path [CR/'+gfa.gfileDir+']:');
if hungupon then exit;
if length(input)=0 then input:=gfa.gfileDir;
p:=input;
if input[length(p)]<>'\' then p:=p+'\';
b:=true;
assign (f,p+'CON');
reset (f);
q:=ioresult;
close (f);
r:=ioresult;
if q<>0 then begin
writestr (' Path does not exist. Create it? [y/n]: *');
b:=yes;
if b then begin
mkdir (copy(p,1,length(p)-1));
q:=ioresult;
b:=q=0;
if b then writestr ('Directory created.')
else writestr ('Unable to create directory.')
end
end
until b;
getapath:=p;
end;
procedure fastlistfile (n:integer);
var q:sstr;
begin
seekgfile (n);
read (gfile,gf);
writeln;
ansicolor (urec.promptcolor);
tab (strr(n)+'.',5);
ansicolor (urec.regularcolor);
if break then exit;
if gf.arcname='' then begin
if exist(getfname(gf.path,gf.fname)) then
tab (strlong(gf.filesize),9) else tab ('Offline',9);
end else tab ('Archived',9);
if break then exit;
ansicolor (urec.statcolor);
tab (gf.gfiledescr,66);
ansicolor (urec.regularcolor);
if break then exit;
end;
function nofiles:boolean;
begin
if Numgfiles=0 then begin
nofiles:=true;
writestr (^M'Sorry, No G-Files!')
end else nofiles:=false
end;
procedure fastlistgfiles;
var cnt,max,r1,r2,r3:integer;
begin
if nofiles then exit;
writehdr ('General File List');
max:=Numgfiles;
thereare (max,'G-File','G-Files');
parserange (max,r1,r2);
if r1=0 then exit;
tab ('No.',5);
tab ('Bytes',9);
tab ('Description',66);
writeln;
r3:=0;
for cnt:=r1 to r2 do begin
r3:=r3+2;
FASTlistfile (cnt);
if break then exit
end;
writeln;
end;
function GetgfileNum (t:mstr):integer;
var n,s:integer;
function SearchforFile (f:sstr):integer;
var cnt:integer;
begin
for cnt:=1 to numgfiles do begin
seekgfile (cnt);
read (gfile,gf);
if match(gf.fname,f) then begin
searchforfile:=cnt;
exit
end
end;
searchforfile:=0
end;
begin
getgfilenum:=0;
if length(input)>1 then input:=copy(input,2,255) else
repeat
writestr ('File Number to '+t+' [?/List]:');
if hungupon or (length(input)=0) then exit;
if input='?' then begin
fastlistgfiles;
input:=''
end
until input<>'';
val (input,n,s);
if s<>0 then begin
n:=searchforfile(input);
if n=0 then begin
writeln ('No such file.');
exit
end
end;
if (n<1) or (n>numgfiles) then writeln ('Invalid number.')
else getgfilenum:=n
end;
procedure addfile (gf:gfileRec);
begin
seekgfile (numgfiles+1);
write (gfile,gf)
end;
function getfsize (filename:anystr):longint;
var df:file of byte;
begin
gf.filesize:=-1;
assign (df,filename);
reset (df);
if ioresult<>0 then exit;
getfsize:=filesize(df);
close(df)
end;
const beenaborted:boolean=false;
function Aborted:boolean;
begin
if beenaborted then begin
aborted:=true;
exit
end;
aborted:=xpressed or hungupon;
if xpressed then begin
beenaborted:=true;
writeln (^B'[New-Scan Aborted!]')
end
end;
procedure NewScan;
var cnt:integer;
first:integer;
newest:boolean;
label notlater;
begin
newest:=false;
beenaborted:=false;
first:=0;
for cnt:=filesize(gfile) downto 1 do begin
Seekgfile (cnt);
read (gfile,gf);
if later (datestr(gf.when),timestr(gf.when),datestr(laston),timestr(laston))
then first:=cnt
else goto notlater
end;
notlater:
if first<>0 then begin
writeln;
writeln (^M'G-File Area: ['^S+gfa.name+^R']');
for cnt:=first to filesize(gfile) do begin
if aborted then exit;
fastlistfile (cnt);
end
end
end;
procedure SetArea (n:integer);
var otay:boolean;
begin
curarea:=n;
otay:=false;
if (n>numareas) or (n<1) then begin
writeln (^B'Invalid Area!');
if issysop then if makearea then setarea (curarea)
else setarea (1)
else setarea (1);
exit
end;
seekgfilea (n);
read (gfilea,gfa);
otay:=(urec.gfLevel>=gfa.Level);
if not otay then
if curarea=1 then error ('Access Level too low!','','')
else begin
reqlevel (gfa.level);
setarea (1);
exit
end;
Assigngf(n);
close (gfile);
reset (gfile);
if ioresult<>0 then rewrite (gfile);
if showit then writeln (^B^M'G-File Area: '^S,gfa.name,^R' ['^S,curarea,^R']');
if showit=false then writeln;
end;
procedure newscanall;
var cnt:integer;
otay:boolean;
begin
writehdr ('New-Scanning - Press [X] to abort.');
if aborted then exit;
for cnt:=1 to filesize(gfilea) do begin
seekgfilea (cnt);
read (gfilea,gfa);
otay:=false;
if urec.gfLevel>=gfa.Level then otay:=true;
if otay then begin
if aborted then exit;
setarea (cnt);
if aborted then exit;
newscan;
end;
if aborted then exit
end;
end;
procedure listareas;
var cnt,old:integer;
gfatmp:gfilearea;
begin
writehdr ('Area List');
old:=curarea;
seekgfileA (1);
writeln(^M'Num Level Name');
for cnt:=1 to NumAreas do begin
read (gfilea,gfatmp);
if (urec.level>=gfatmp.Level) then begin
write (^R,cnt:2,'. ['^S);
tab(strr(gfatmp.Level),5);
writeln(^R'] '^S,gfatmp.Name,^R);
if break then begin
setarea(old);
exit;
end;
end;
end;
end;
function GetAreaNum:integer;
var areastr:sstr;
areanum:integer;
begin
getareanum:=0;
if length(input)>1 then areastr:=copy(input,2,255) else
begin
repeat
listareas;
writestr (^M'Area Number [?/List]:');
if input='!' then listareas else areastr:=input
until (input<>'?') or hungupon;
end;
if length(areastr)=0 then exit;
areanum:=valu(areastr);
if (areanum>0) and (areanum<=NumAreas) then getareanum:=areanum
else begin
writestr ('No such Area!');
if issysop then if makearea then getareanum:=numareas
end;
end;
procedure GetArea;
var areanum:integer;
begin
areanum:=getareanum;
if areanum<>0 then SetArea (areanum);
end;
procedure yourgfstatus;
begin
if asciigraphics in urec.config then begin
writeln (^B'┌─────────────────┬────────────────┐');
write ('│ G-File Level │ '^S);
tab (strr(urec.gflevel),15);
writeln (^R'│');
write ('│ Required Ratio │ '^S);
tab (strr(gfratio)+'%',15);
writeln(^R'│');
write ('│ G-file U/D Ratio│ '^S);
tab (strr(percent(urec.gfuploads,urec.gfdownloads)),15);
writeln (^R'│');
write ('│ G-File Uploads │ '^S);
tab (strr(urec.gfuploads),15);
writeln (^R'│');
write ('│ G-File Downloads│ '^S);
tab (strr(urec.gfdownloads),15);
writeln (^R'│');
if useqr then begin
calcqr;
write ('│ Quality Rating │ '^S);
tab (strr(qr),15);
writeln (^R'│');
end;
writeln ('└─────────────────┴────────────────┘');
end else begin
writeln (^B'+-----------------+----------------+');
write ('| G-File Level | '^S);
tab (strr(urec.gflevel),15);
writeln (^R'|');
write ('| Required Ratio | '^S);
tab (strr(gfratio)+'%',15);
writeln(^R'|');
write ('| G-file U/D Ratio| '^S);
tab (strr(percent(urec.gfuploads,urec.gfdownloads)),15);
writeln (^R'|');
write ('| G-File Uploads | '^S);
tab (strr(urec.gfuploads),15);
writeln (^R'|');
write ('| G-File Downloads| '^S);
tab (strr(urec.gfdownloads),15);
writeln (^R'|');
if useqr then begin
calcqr;
write ('| Quality Rating | '^S);
tab (strr(qr),15);
writeln (^R'|');
end;
writeln ('+-----------------+----------------+');
end;
if percent (urec.gfuploads,urec.gfdownloads)<udratio then begin
writeln ('Your UL/DL ratio is too low!');
exit;
end;
end;
procedure showgfile (n:integer);
var f,wipefile:file;
protop,tran,fn:lstr;
b:integer;
ascii,crcmode,ymodem,cool:boolean;
extrnproto:char;
begin
ascii:=false;
seekgfile (n);
read (gfile,gf);
if ulvl<0 then exit;
writeln;
if useqr then begin
calcqr;
if (qr<qrlimit) and (ulvl<qrexempt) then begin
writeln ('Your Quality Rating is '^S+strr(qr)+^R'.');
writeln ('That exceeds the limit of '^S+strr(qrlimit)+^R'!');
writeln ('You must get a better QR before you can download.');
exit;
end;
end;
if (not exist(getfname(gf.path,gf.fname))) and (gf.arcname='') then begin
writeln('File is [Offline]!');
writeln;
exit;
end;
if (gf.arcname<>'') and (not exist (getfname(gf.path,gf.fname))) then begin
writeln;
writeln ('Extracting file from Archive -- Please hold...');
if not exist (gf.arcname) then begin
writeln ('Archive filename '+gf.arcname+' does not exist!');
exit;
end;
extract (gf.fname,gf.arcname,gf.path);
if not exist (gf.path+gf.fname) then begin
writeln ('File could not be extracted. Sorry!');
writeln ('Leave '+sysopname+' Feedback about this please.');
exit;
end;
if exist (uploaddir+gf.fname) then writeln ('Extracted Successfully.');
end;
listprotocols(0);
if hungupon then exit;
writestr(^R+'Protocol '^P'['^R'A'^P'/'^S'Ascii'^P']'^S' - '^P'['^R'CR'^P'/'+^S+urec.defproto+^S' Q'^R'uit'^P']'^R' &');
if hungupon then exit;
if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
if upstring (input)='Q' then exit;
fn:=getfname (gf.path,gf.fname);
ascii:=(extrnproto='A');
if tempsysop then begin
ulvl:=regularlevel;
tempsysop:=false;
writeurec;
bottomline
end;
if not ascii then begin
cool:=findprot('S',extrnproto);
if not cool then exit;
writeln; writeln('Start your download now.');
b:=doext('S',extrnproto,gf.path,gf.fname,baudrate,usecom);
modeminlock:=false;
modemoutlock:=false;
beepbeep (b)
end;
if ascii then begin
writestr ('Press [X] to abort or [CR] to continue: *');
if upcase(input[1])='X' then exit;
writeln (^M^R'Title: '^S,gf.gfiledescr,
^M^R'Date: '^S,datestr (gf.when),
^M^R'Time: '^S,timestr (gf.when),^M);
printfile (getfname(gf.path,gf.Fname));
urec.gfdownloads:=urec.gfdownloads+1;
writeln (asciidownload);
writeln;
end;
if ((gf.arcname<>'') and (exist (getfname(gf.path,gf.fname)))) then
begin
assign (wipefile,getfname(gf.path,gf.fname));
erase (wipefile);
end;
end;
procedure makeasciigfile (filename:anystr);
var t:text;
b:boolean;
yo:integer;
fname:lstr;
begin
assign (t,filename);
rewrite (t);
writeln;
if (asciigraphics in urec.config) then
writeln ('──────────────────────────────────────────────────────────') else
writeln ('----------------------------------------------------------');
writeln ('[Enter G-File now (Echo''d) - Type /S to Save, /A to Abort]');
if (asciigraphics in urec.config) then
writeln ('──────────────────────────────────────────────────────────') else
writeln ('----------------------------------------------------------');
writeln;
repeat
lastprompt:='Continue...'^M;
wordwrap:=true;
getstr (1);
b:=match(input,'/S') or match(input,'/A');
if not b then writeln (t,input)
until b;
textclose (t);
if match(input,'/A') then erase (t);
writelog (3,2,Filename);
end;
procedure uploadgfile;
var tx,t:text;
ascii,crcmode,bbb,cool:boolean;
yo:integer;
fname,tran,protop,fn:lstr;
extrnproto:char;
emmemm:minuterec;
begin
writeln;
crcmode:=false;
ymodem:=false;
if gfa.upable=false then begin
writeln ('Sorry, Uploading is not allowed in this area!');
writeln;
exit;
end;
writehdr('Upload G-Files');
repeat
writestr ('Upload Filename: *');
if length(input)=0 then exit;
until validfname (input);
gf.fname:=input;
fn:=getfname(gfa.gfiledir,gf.fname);
if not exist(fn) then begin
writestr ('Description: &');
gf.gfiledescr:=input;
assign (tx,fn);
listprotocols(1);
if hungupon then exit;
writestr(^R+'Protocol '^P'['^R'A'^P'/'^S'Ascii'^P']'^S' - '^P'['^R'CR'^P'/'+^S+urec.defproto+^S' Q'^R'uit'^P']'^R' &');
if hungupon then exit;
if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
if upstring (input)='Q' then exit;
ascii:=(extrnproto='A');
if tempsysop then begin
ulvl:=regularlevel;
tempsysop:=false;
writeurec;
bottomline
end;
starttimer (emmemm);
if not ascii then begin
ascii:=false;
yo:=0;
gf.arcname:='';
cool:=findprot('R',extrnproto);
if not cool then exit;
yo:=doext('R',extrnproto,gfa.gfiledir,gf.fname,baudrate,usecom);
modeminlock:=false;
modemoutlock:=false;
beepbeep (yo);
case yo of
0 : writelog (3,2,fn);
1,2 : begin
assign(tx,fn);
erase(tx);
end;
end;
end;
if ascii then begin
assign (t,fn);
rewrite (t);
writeln;
if (asciigraphics in urec.config) then
writeln ('─────────────────────────────────────────────────────────────────') else
writeln ('-----------------------------------------------------------------');
writeln ('Enter G-File now (Echoed) - [/S] to Save, [/A] to Abort');
if (asciigraphics in urec.config) then
writeln ('─────────────────────────────────────────────────────────────────') else
writeln ('-----------------------------------------------------------------');
writeln;
repeat
lastprompt:='Continue...'^M;
wordwrap:=true;
getstr (1);
bbb:=match(input,'/S') or match(input,'/A');
if not bbb then begin
writeln (t,input);
end;
until bbb;
textclose (t);
if match(input,'/A') then erase (t);
writelog (3,2,fn);
end
end else writeln (^M'File exists!'^M);
stoptimer (emmemm);
writeln;
if not exist (fn) then begin
writeln ('Upload Aborted!');
exit;
end else writeln ('Thanks for the upload!');
gf.when:=now;
gf.sentby:=unam;
gf.path:=gfa.gfiledir;
gf.downloaded:=0;
gf.specialfile:=false;
gf.newfile:=true;
gf.filesize:=getfsize (fn);
urec.gfuploads:=urec.gfuploads+1;
seekgfile (numgfiles+1);
write (gfile,gf);
if gfilez>32760 then gfilez:=0;
gfilez:=gfilez+1;
writeln;
writelog (3,10,gf.gfiledescr)
end;
procedure sysopcommands;
var q:integer;
procedure getstr (prompt:mstr; var ss; len:integer);
var a:anystr absolute ss;
begin
writeln (^B^M'Current ',prompt,' is: '^S,a);
buflen:=len;
writestr ('Enter new '+prompt+':');
if length(input)>0 then a:=input;
end;
procedure getint (prompt:mstr; var i:integer);
var q:sstr;
n:integer;
begin
str (i,q);
getstr (prompt,q,5);
n:=valu (q);
if n<>0 then i:=n
end;
procedure getboo (t:lstr; var b:boolean);
var s:sstr;
begin
s:=yesno (b);
getstr (t,s,1);
b:=upcase(s[1])='Y'
end;
procedure removefile (n:integer);
var cnt:integer;
begin
for cnt:=n to numgfiles-1 do begin
seekgfile (cnt+1);
read (gfile,gf);
seekgfile (cnt);
write (gfile,gf)
end;
seekgfile (numgfiles);
truncate (gfile)
end;
procedure addgfile;
var fn,s,p:anystr;
found:boolean;
t:text;
begin
found:=false;
writestr ('Filename: *');
if length(input)=0 then exit;
if match(input,'USERS') then begin
writelog (3,12,unam);
writeln (^G^M'Too bad, you can''t add the USER file!'^M);
exit;
end;
gf.fname:=input;
writestr ('Path [CR/'+gfa.gfileDir+']: *');
if length(input)=0 then input:=gfa.gfiledir;
gf.path:=input;
p:=gf.path;
if exist (faqdir+'SECURITY.DIR') then begin
assign (t,faqdir+'SECURITY.DIR');
reset (t);
repeat
readln (t,s);
if s[length(s)]<>'\' then s:=s+'\';
if match(s,p) then begin
found:=true;
writeln;
writeln (^G'That Directory is protected by the Sysop!');
writeln;
end;
until eof(t) or (found);
textclose (t);
if found then exit;
end;
writestr ('Archive Filename [CR/None]: *');
if length(input)<2 then gf.arcname:='' else
gf.arcname:=input;
if gf.arcname='' then begin
fn:=getfname(gf.path,gf.fname);
if not exist(fn) then begin
writestr ('File not found! Enter file now? [y/n]: *');
if yes then makeasciigfile(fn)
end;
if not exist(fn) then exit;
end;
writestr ('Description:');
if length(input)=0 then exit;
gf.gfiledescr:=input;
writestr ('Sent by [CR/'+unam+']:');
if length(input)=0 then input:=unam;
gf.sentby:=input;
gf.filesize:=getfsize(fn);
gf.when:=now;
gf.downloaded:=0;
gf.specialfile:=false;
gf.newfile:=false;
seekgfile (numgfiles+1);
write (gfile,gf);
if gfilez>32760 then gfilez:=0;
gfilez:=gfilez+1;
if urec.lastgfiles>32760 then urec.lastgfiles:=0;
urec.lastgfiles:=urec.lastgfiles+1;
urec.gfuploads:=urec.gfuploads+1;
writelog (3,11,gf.gfiledescr);
writeurec
end;
procedure editgfile;
var n:integer;
fn:anystr;
begin
n:=getgfilenum('Edit');
if n=0 then exit;
seekgfile (n);
read (gfile,gf);
getstr ('Filename',gf.fname,12);
getstr ('Path',gf.path,50);
getstr ('Archive Filename',gf.arcname,80);
if gf.arcname='' then begin
fn:=getfname(gf.path,gf.fname);
if not exist (fn) then begin
write (^B^M,fn,' not found!');
writestr (^M'Create new file '+fn+'? [y/n]: *');
if yes then makeasciigfile(fn);
if not exist(fn) then exit;
end else gf.filesize:=getfsize(fn);
end;
getstr ('Description',gf.gfiledescr,75);
getstr ('Uploader',gf.sentby,28);
getboo ('Special File',gf.specialfile);
getboo ('New file',gf.newfile);
seekgfile (n);
write (gfile,gf);
writelog (3,3,gf.gfiledescr);
end;
procedure killgarea;
var gfatmp:gfilearea;
cnt,n:integer;
oldname,newname:sstr;
begin
gfatmp:=gfa;
writestr ('Delete Area #'+strr(curarea)+' ['+gfatmp.Name+']: *');
if not yes then exit;
gfilez:=gfilez-numgfiles;
urec.lastgfiles:=urec.lastgfiles-numgfiles;
if gfilez<0 then gfilez:=0;
if urec.lastgfiles<0 then urec.lastgfiles:=0;
close (gfile);
oldname:=uploaddir+'gfile'+strr(curarea);
assign (gfile,oldname);
erase (gfile);
for cnt:=curarea to numareas-1 do begin
newname:=oldname;
oldname:=uploaddir+'gfile'+strr(cnt+1);
assign (gfile,oldname);
rename (gfile,newname);
n:=ioresult;
Seekgfilea (cnt+1);
read (gfilea,gfatmp);
seekgfilea (cnt);
write (gfilea,gfatmp);
end;
seekgfilea (numareas);
truncate (gfilea);
setarea (1)
end;
procedure modgarea;
var gfatmp:gfilearea;
begin
gfatmp:=gfa;
getstr ('Area Name',gfatmp.Name,80);
getint ('Access Level',gfatmp.Level);
getstr ('Sponsor',gfatmp.Sponsor,30);
getboo ('Able to Upload here',gfatmp.upable);
getstr ('Upload Dir',gfatmp.gfileDir,50);
seekgfilea (curarea);
write (gfilea,gfatmp);
gfa:=gfatmp;
end;
procedure deletegfile;
var cnt,n,anarky:integer;
f:file;
gfn:lstr;
floyd:userrec;
begin
n:=getgfilenum ('Delete');
if n=0 then exit;
seekgfile (n);
read (gfile,gf);
gfn:=getfname(gf.path,gf.fname);
gfn:=upstring(gfn);
writeln;
writehdr ('Delete G-File');
writeln (^R'Filename: '^S,gfn);
writeln (^R'Size: '^S,strlong(gf.filesize));
writeln (^R'Description: '^S,gf.gfiledescr);
writeln (^R'Uploader: '^S,gf.sentby);
writeln (^R);
writestr ('Delete this? [y/n]: *');
if not yes then exit;
writestr ('Erase Disk File '+gfn+'? *');
if yes then begin
if gf.arcname='' then begin
assign (f,getfname(gf.path,gf.fname));
erase (f);
if ioresult<>0 then writestr ('Couldn''t erase File.')
end else
writeln ('G-File is inside Archive; can''t erase it from here.');
end;
for cnt:=n+1 to numgfiles do begin
seekgfile (cnt);
read (gfile,gf);
seekgfile (cnt-1);
write (gfile,gf)
end;
seekgfile (numgfiles);
truncate (gfile);
if gfilez<0 then gfilez:=0;
gfilez:=gfilez-1;
if urec.lastgfiles<0 then urec.lastgfiles:=0;
urec.lastgfiles:=urec.lastgfiles-1;
writeurec;
writestr ('Remove Upload Credits from uploader? [y/n]: *');
if yes then begin
anarky:=lookupuser (gf.sentby);
if anarky<>0 then begin
writeurec;
seek (ufile,anarky);
read (ufile,floyd);
floyd.gfuploads:=floyd.gfuploads-1;
seek (ufile,anarky);
write (ufile,floyd);
readurec
end;
end;
writestr (^M'Deleted.');
writelog (3,4,gf.gfileDescr)
end;
procedure SortGArea;
var temp,mark,cnt,method:integer;
v1,v2:string[80];
gftmp:gfileRec;
begin
writehdr ('Sort G-Files');
writeln;
writeln ('[0]:Quit');
writeln ('[1]:Description');
writeln ('[2]:Filename');
writeln;
writestr ('Enter method: *');
method:=valu(input[1]);
if method=0 then exit;
mark:=numgfiles-1;
repeat
if mark<>0 then begin
temp:=mark;
mark:=0;
for cnt:=1 to temp do begin
seekgfile (cnt);
read (gfile,gf);
read (gfile,gftmp);
if method=1 then begin
v1:=upstring(gf.gfiledescr);
v2:=upstring(gftmp.gfiledescr);
end else begin
v1:=upstring(gf.fname);
v2:=upstring(gftmp.fname);
end;
if v1>v2 then begin
mark:=cnt;
seekgfile (cnt);
write (gfile,gftmp);
write (gfile,gf)
end
end
end
until mark=0
end;
procedure reordergareas;
var cura,newa:integer;
gfatmp:gfilearea;
f1,f2:file;
fn1,fn2:sstr;
label exit;
begin
writehdr ('Reorder G-File Areas');
writeln (^M'Number of G-File areas: ',numareas:1);
for cura:=0 to numareas-2 do begin
repeat
writestr (^M^J+'New Area #'+strr(cura+1)+' [?/List]-[CR/Quit]:');
if length(input)=0 then goto exit;
if input='?' then begin
listareas;
newa:=-1
end else begin
newa:=valu(input)-1;
if (newa<0) or (newa>=numareas) then begin
writeln ('Not found! Please re-enter...');
newa:=-1
end
end
until (newa>0);
seek (gfilea,cura);
read (gfilea,gfa);
seek (gfilea,newa);
read (gfilea,gfatmp);
seek (gfilea,cura);
write (gfilea,gfatmp);
seek (gfilea,newa);
write (gfilea,gfa);
fn1:=uploaddir+'gfile';
fn2:=fn1+strr(newa+1);
fn1:=fn1+strr(cura+1);
assign (f1,fn1);
assign (f2,fn2);
rename (f1,'Temp$$$$.%%%');
rename (f2,fn1);
rename (f1,fn2)
end;
exit:
setarea (1)
end;
procedure Movegfile;
var an,fn,old:integer;
newfilesam,sambam,filesam,wangbang:anystr;
darn:file;
gftmp:gfileRec;
begin
fn:=GetgfileNum ('Move');
old:=curarea;
if fn=0 then exit;
input:='';
an:=GetAreaNum;
if an=0 then exit;
Seekgfile (fn);
read (gfile,gftmp);
if gftmp.arcname<>'' then begin
writeln (^M'G-File is inside Archive ',gftmp.arcname,'. Cannot move.'^M);
exit;
end;
removefile (fn);
writestr('Physically move the file to correct area? *');
write ('Moving...');
filesam:=Getfname(gftmp.path,gftmp.fname);
sambam:=gftmp.path;
setarea(an);
if (sambam<>gfa.gfileDir) then if yes then begin
gftmp.path:=gfa.gfileDir;
newfilesam:=Getfname(gftmp.path,gftmp.fname);
exec('Copy',' '+filesam+' '+newfilesam+' >temp');
wangbang:=filesam;
assign(darn,wangbang);
if exist(newfilesam) then erase (darn) else begin
gftmp.path:=sambam;
writeln('Uh oh... Bad error!');
end;
end;
setarea (An);
Addfile (gftmp);
setarea (old);
writeln (^B'Done.')
end;
procedure getpathname (fname:lstr; var path:lstr; var name:sstr);
var p:integer;
begin
path:='';
repeat
p:=pos('\',fname);
if p<>0 then begin
path:=path+copy(fname,1,p);
fname:=copy(fname,p+1,255)
end
until p=0;
name:=fname
end;
procedure displayfile (var ffinfo:searchrec);
var a:integer;
begin
a:=ffinfo.attr;
if (a and 8)=8 then exit;
tab (ffinfo.name,13);
if (a and 16)=16
then write ('Directory')
else write (ffinfo.size);
if (a and 1)=1 then write (' <read-only>');
if (a and 2)=2 then write (' <hidden>');
if (a and 4)=4 then write (' <system>');
writeln
end;
procedure getfsize (var g:gfilerec);
var df:file of byte;
begin
g.filesize:=-1;
assign (df,getfname(g.path,g.fname));
reset (df);
if ioresult<>0 then exit;
g.filesize:=filesize(df);
close(df)
end;
procedure addresidentgfile (fname:lstr);
var g:gfilerec;
fn:anystr;
begin
getpathname (fname,g.path,g.fname);
getfsize (g);
if g.filesize=-1 then begin
writeln ('File can''t be opened!');
exit
end;
buflen:=70;
writestr ('Description: &');
g.gfiledescr:=input;
getfsize (g);
g.when:=now;
g.sentby:=unam;
g.downloaded:=0;
g.specialfile:=false;
g.newfile:=false;
g.arcname:='';
seekgfile (numgfiles+1);
write (gfile,g);
gfilez:=gfilez+1;
writeln;
writelog (3,11,g.gfiledescr)
end;
procedure addmultiplegfiles;
var spath,pathpart:lstr;
dummy:sstr;
f:file;
ffinfo:searchrec;
begin
if ulvl<sysoplevel then begin
writeln (
'Sorry, you may not add resident files without true sysop access!');
exit
end;
writehdr ('Add Resident G-Files By Wildcard');
writestr ('Search path/wildcard:');
if length(input)=0 then exit;
spath:=input;
if spath[length(spath)]='\' then dec(spath[0]);
assign (f,spath+'\con');
reset (f);
if ioresult=0 then begin
close (f);
spath:=spath+'\*.*'
end;
getpathname (spath,pathpart,dummy);
findfirst (spath,$17,ffinfo);
if doserror<>0
then writeln ('No files found!')
else
while doserror=0 do begin
writeln;
displayfile (ffinfo);
writestr ('Add this file? [Y/N/X]: *');
if yes
then addresidentgfile (getfname(pathpart,ffinfo.name))
else if (length(input)>0) and (upcase(input[1])='X')
then exit;
findnext (ffinfo)
end
end;
function defaultdrive:byte;
var r:registers;
begin
r.ah:=$19;
intr ($21,r);
defaultdrive:=r.al+1
end;
function unsigned (i:integer):real;
begin
if i>=0
then unsigned:=i
else unsigned:=65536.0+i
end;
procedure writefreespace (path:lstr);
var drive:byte;
r:registers;
csize,free,total:real;
begin
r.ah:=$36;
r.dl:=ord(upcase(path[1]))-64;
intr ($21,r);
if r.ax=-1 then begin
writeln ('Invalid drive');
exit
end;
csize:=unsigned(r.ax)*unsigned(r.cx);
free:=csize*unsigned(r.bx);
total:=csize*unsigned(r.dx);
free:=free/1024;
total:=total/1024;
writeln (free:0:0,'k out of ',total:0:0,'k')
end;
procedure directory;
var r:registers;
ffinfo:searchrec;
tpath:anystr;
b:byte;
cnt:integer;
begin
getdir (defaultdrive,tpath);
if tpath[length(tpath)]<>'\' then tpath:=tpath+'\';
tpath:=tpath+'*.*';
writestr ('Path/Wildcard [CR for '+tpath+']:');
writeln (^M);
if length(input)<>0 then tpath:=input;
writelog (16,10,tpath);
findfirst (chr(defaultdrive+64)+':\*.*',8,ffinfo);
if doserror<>0
then writeln ('No volume label'^M)
else writeln ('Volume label: ',ffinfo.name,^M);
findfirst (tpath,$17,ffinfo);
if doserror<>0 then writeln ('No files found.') else begin
cnt:=0;
while doserror=0 do begin
cnt:=cnt+1;
if not break then displayfile (ffinfo);
findnext (ffinfo)
end;
writeln (^B^M'Total Files: ',cnt)
end;
write ('Free Disk Space: ');
writefreespace (tpath)
end;
begin
if not issysop then begin
reqlevel (sysoplevel);
exit
end;
repeat
q:=menu ('G-File Sysop','SGFILE','QACD?KRMSOW@F');
case q of
2:addgfile;
3:editgfile;
4:deletegfile;
5:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
G-File Sysop Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Add G-Files
║HC║ [
C
s');
writeln ('u
]
Change G-File
║HC║ [
s');
writeln ('u
D
]
Delete G-File
║H
s');
writeln ('u
C║ [
K
]
Kill G-File Area
s');
writeln ('u
║HC║ [
M
]
Move G-File
s');
writeln ('u
║HC║ [
N
]
Newscan G-Files
s');
writeln ('u
║HC║ [
O
]
Re-Order G
s');
writeln ('u
-Files
║HC║ [
Q
]
Qui
s');
writeln ('u
t
║HC║ [
R
]
s');
writeln ('u
Rename G-File Area
║HC║ [
S
s');
writeln ('u
]
Sort G-File Area
║HC║
s');
writeln ('u
[
W
]
Add Multiple G-Files
║H
s');
writeln ('u
C║ [
?
]
View This Menu
s');
writeln ('u
║HC╚═════════════════════════════════════╝
');
writeln;
pause;
end;
6:killgarea;
7:modgarea;
8:movegfile;
9:sortgarea;
10:reordergareas;
11:addmultiplegfiles;
12:directory;
end
until hungupon or (q=1)
end;
var prompt:lstr;
n:integer;
k:char;
q1:mstr;
a:arearec;
ms:boolean;
dammit:boolean;
q:integer;
x1,x2,x3,zxcv1,zxcv2:integer;
y1,y2,y3:real;
begin
dammit:=false;
showit:=true;
writehdr ('G-Files Section');
writeln;
itsotay:=false;
{if numareas>0 then}
opengfile;
if not itsotay then exit;
seekgfilea(1);
read (gfilea,gfa);
if (urec.gfLevel<gfa.Level) then begin
writeln('You don''t have access to the G-Files Section.');
exit;
end;
x1:=urec.nbu;
x2:=urec.numon;
if x1<1 then x1:=1;
if x2<1 then x2:=1;
y1:=int(x1);
y2:=int(x2);
y1:=y1;
y2:=y2;
y3:=y1/y2;
y3:=y3*100;
x3:=trunc(y3);
write (^R'Required Post/Call Ratio: ['^S);
for zxcv1:=1 to 3-(length(strr(gfpcr))) do write (' ');
write (strr(gfpcr));
writeln ('%'^R']');
write (^R'Your Post/Call Ratio: ['^S);
for zxcv2:=1 to 3-(length(strr(x3))) do write (' ');
write (strr(x3));
writeln ('%'^R']');
writeln;
write (^R'PCR Status: ['^S);
if ulvl>=pcrexempt then write ('Exempt from PCR.') else
if (x3<gfpcr) and (ulvl<pcrexempt) then write ('PCR too low!') else
if (x3>=gfpcr) and (ulvl<pcrexempt) then write ('Passed PCR check.');
writeln (^R']');
writeln;
if (x3<gfpcr) and (ulvl<pcrexempt) then begin
writeln (^B^R'Your Posts-per-Call Ratio is too low!');
writeln ('Go post a message or two.');
close (gfile);
close (gfilea);
exit;
end;
yourgfstatus;
setarea(1);
repeat
prompt:='';
q:=menu ('G-File','GFILE','QU%FAYNVDLG?');
case q of
1:begin
close(gfile);
close(gfilea);
end;
2:uploadgfile;
3:sysopcommands;
4:fastlistgfiles;
5:getarea;
6:yourgfstatus;
7:newscanall;
8:newscan;
9:begin
n:=getgfilenum ('Download');
if n>0 then showgfile(n);
end;
10:fastlistgfiles;
11:offfaq;
12:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
G-File Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Change Active G-File Area
║HC║ [
D
s');
writeln ('u
]
Download G-File
║HC║ [
s');
writeln ('u
F
]
Fast List G-Files
║H
s');
writeln ('u
C║ [
G
]
Log off BBS
s');
writeln ('u
║HC║ [
L
]
List G-Files
s');
writeln ('u
║HC║ [
N
]
Newscan All G-Fil
s');
writeln ('u
e Areas
║HC║ [
Q
]
Quit
s');
writeln ('u
║HC║ [
U
]
Upl
s');
writeln ('u
oad G-File
║HC║ [
V
]
s');
writeln ('u
Newscan Current Area
║HC║ [
Y
s');
writeln ('u
]
Your G-File Statistics
║HC║
s');
writeln ('u
[
%
]
G-File Sysop Section
║H
s');
writeln ('u
C║ [
?
]
View This Menu
s');
writeln ('u
║HC╚═════════════════════════════════════╝
');
writeln;
pause;
end;
end;
until hungupon or (q=1);
end;
begin
end.